home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 January - Disc 2 / Macworld (1999-01) (Disk 2).dmg / Serious Demos / Symbolic Composer 4.2 / Environment / System / CADAR / Symbols / Ornamentation / apply-on-which next >
Lisp/Scheme  |  1998-10-22  |  3KB  |  80 lines
  1. apply-on-which 
  2. which original-material processed-material
  3. &optional original-material-2 processed-material-2
  4.  
  5. sometimes after processing material you want
  6. to keep only some of the result
  7.  
  8. this function only works if you have kept
  9. the original to compare with.
  10.  
  11. material in which must match material
  12. in original-material 
  13.  
  14.  
  15.  
  16. (setq org-syms '(a b c d b c a d))
  17. ->(a b c d b c a d)
  18. (setq pros-syms (symbol-transpose 12 org-syms))
  19. ->(m n o p n o m p) ;everything transposed
  20.  
  21. (apply-on-which '(a b) org-syms pros-syms) 
  22. ->(m n c d n c m d) ;removes transposition on all but
  23. those who matches which
  24.  
  25. most times it's easier to do like this
  26. (mapcar #'(lambda (x) (if (or (eq x 'a) (eq x 'b))
  27. (transpose-symbol x 12) x)) org-syms) 
  28. ->(m n c d n c m d)
  29.  
  30. or to make your own little function:
  31.  
  32. (defun symbol-transpose-if (which trans symbols)
  33.       (mapcar #'(lambda (x) (if (find x which) 
  34.        (transpose-symbol x trans) x)) symbols))
  35.  
  36. (symbol-transpose-if '(a b) 12 org-syms)
  37. ->(m n c d n c m d)
  38.  
  39.  
  40.  
  41.  
  42. (setq org-rhys '(1/4 1/2 1/4 1/2 1/1 1/8 1/2 1/8))
  43. (setq pros-rhys (change-length times 2 org-rhys))
  44.  
  45. (apply-on-which '(1/2) org-rhys pros-rhys)
  46. ->(1/4 1920 1/4 1920 1/1 1/8 1920 1/8)
  47.  
  48.  
  49. (apply-on-which '(1/2) org-rhys pros-rhys 
  50.                org-syms pros-syms)
  51. ->((1/4 1920 1/4 1920 1/1 1/8 1920 1/8) 
  52.    (a n c p b c m d))
  53.  
  54.  
  55. I made this function instead of having to change
  56. my different ornament-functions
  57.  
  58. (setq s1 (noergaard-infinity-series 21 '(a b)))
  59. ->(a b -b c b a -c d -b c a b c -b -d e b a -c d a) 
  60.  
  61. (setq r1 (make-rhythms 
  62.           (noergaard-infinity-series 21 '(8 9))
  63.           (make-list 21 :initial-element 8)))
  64. ->(1/1 9/8 7/8 5/4 9/8 1/1 3/4 11/8 7/8 5/4 1/1 9/8    5/4 7/8 5/8 3/2 9/8 1/1 3/4 11/8 1/1)
  65.  
  66. (setq mat (multi-rnd-ornament 3 5 r1 s1 :seed 0.1)) 
  67. ->(((a -b a) (b a b) (-b -c) (c b) (b a b a) (a -b) (-c -d -c) (d e) (-b a -b) (c d c) (a b) (b c) (c b c) (-b a) (-d -e) (e d) (b a) (a -b a) (-c -d) (d e) (a -b a)) ((2/5 2/5 1/5) (9/16 9/32 9/32) (21/40 7/20) (15/16 5/16) (9/32 9/32 9/32 9/32) (1/3 2/3) (3/8 3/16 3/16) (11/12 11/24) (7/32 7/16 7/32) (1/2 1/2 1/4) (1/2 1/2) (9/10 9/40) (5/16 5/8 5/16) (7/20 21/40) (5/12 5/24) (9/8 3/8) (3/8 3/4) (1/2 1/4 1/4) (1/2 1/4) (33/32 11/32) (2/5 2/5 1/5)))
  68.  
  69.  
  70. (setq new-mat (apply-on-which '(a) s1 (car mat)
  71.                                r1 (cadr mat)))
  72. ->(((a -b a) b -b c b (a -b) -c d -b c (a b) b c -b -d e b (a -b a) -c d (a -b a)) ((2/5 2/5 1/5) 9/8 7/8 5/4 9/8 (1/3 2/3) 3/4 11/8 7/8 5/4 (1/2 1/2) 9/8 5/4 7/8 5/8 3/2 9/8 (1/2 1/4 1/4) 3/4 11/8 (2/5 2/5 1/5)))
  73.  
  74.  
  75. or
  76.  
  77. (setq new-mat2 (apply-on-which '(7/8 9/8) r1 
  78. (cadr mat) s1 (car mat)))
  79. ->((1/1 (9/16 9/32 9/32) (21/40 7/20) 5/4 (9/32 9/32 9/32 9/32) 1/1 3/4 11/8 (7/32 7/16 7/32) 5/4 1/1 (9/10 9/40) 5/4 (7/20 21/40) 5/8 3/2 (3/8 3/4) 1/1 3/4 11/8 1/1) (a (b a b) (-b -c) c (b a b a) a -c d (-b a -b) c a (b c) c (-b a) -d e (b a) a -c d a))
  80.